;File:	METAMIND.LSP		    03/06/91		Soft Warehouse, Inc.


;	     * * *   The Metamind Code Breaking Game   * * *

(DEFUN METAMIND (
    *INTERRUPT-HOOK* *META-WINDOW* CHAR)
  (SETQ *META-WINDOW* (MAKE-WINDOW))
  ((METAMIND-DISPLAY)
    (UNWIND-PROTECT
     (LOOP
      (META-PROMPT-WINDOW)
      (SET-CURSOR 1 0)
      (CENTER "Press any key to play or ESC to quit.")
      (CLEAR-INPUT)
      ((EQ (READ-BYTE) 27))
      (CLEAR-SCREEN)
      (WRITE-SENTENCE "Do you want to be the code Maker ")
      (WRITE-SENTENCE "or the code Breaker? (M/B) ")
      (LOOP
	(SETQ CHAR (READ-BYTE))
	((EQ CHAR 27)
	  (RETURN) )
	(SETQ CHAR (CHAR-UPCASE (ASCII CHAR)))
	((EQ CHAR 'M)
	  (PLAY-CODE-MAKER) )
	((EQ CHAR 'B)
	  (PLAY-CODE-BREAKER) )
	(WRITE-BYTE 7) ) )
     (APPLY 'MAKE-WINDOW *META-WINDOW*)
     (CLEAR-SCREEN) ) ) )

(DEFUN METAMIND-DISPLAY ()
  (CLEAR-SCREEN)
  (CENTER "The Metamind Code Breaking Game")
  (TERPRI 2)
  ((OR (< (CADDR (MAKE-WINDOW)) 8)
       (< (CADDDR (MAKE-WINDOW)) 37))
    (WRITE-SENTENCE "Window to small to play Metamind.")
    NIL )
  (WRITE-SENTENCE "The object of this game is to logically determine the ")
  (WRITE-SENTENCE "colors and arrangement of four objects based on clues ")
  (WRITE-SENTENCE "provided by the code Maker.	The computer can play ")
  (WRITE-SENTENCE "either the code Maker or the code Breaker.")
  T )

(DEFUN PLAY-CODE-MAKER (
    MOVE GRAPH GUESS-CTR KEYLST BLACKS WHITES MOVE-ROW MOVE-COL)
  (SETQ *KEYLIST* (MAPCAR 'PERMUTE-CODE *KEYLIST*)
	MOVE (FIRST-MOVE (CAR *KEYLIST*))
	GRAPH (NUGRAPH MOVE)
	GUESS-CTR 1)
  (META-OUTPUT-WINDOW)
  (CLEAR-SCREEN)
  (CENTER "The Metamind Code Breaking Game")
  (TERPRI 2)
  (WRITE-SENTENCE "So you want to challenge the champ!	")
  (WRITE-SENTENCE "Ok, think up a secret code consisting of any sequence ")
  (WRITE-SENTENCE "of four colors from those listed below.  ")
  (WRITE-SENTENCE "Colors in the code can be repeated.	Press any key ")
  (WRITE-SENTENCE "when you are ready for me to make a guess.")
  (TERPRI 2)
  (SETQ MOVE-ROW (ROW)
	MOVE-COL (MAX 0 (TRUNCATE (- (CADDDR *META-WINDOW*) 35) 2)))
  (META-PROMPT-WINDOW)
  (CLEAR-SCREEN)
  (CENTER "Blue  Green	Pink  Red  White  Yellow")
  (TERPRI)
  (CENTER "Press any key to play or ESC to quit.")
  (CLEAR-INPUT)
  ((EQ (READ-BYTE) 27)
    (CLEAR-SCREEN) )
  (LOOP
    (META-OUTPUT-WINDOW)
    (SET-CURSOR MOVE-ROW MOVE-COL)
    (WRITE-STRING "Move: ")
    (PRIN1 GUESS-CTR)
    (SET-CURSOR MOVE-ROW (+ MOVE-COL 10))
    (MAPC '(LAMBDA (COLOR) (PRINC COLOR) (SPACES 2)) MOVE)
    (META-PROMPT-WINDOW)
    (CLEAR-SCREEN)
    (WRITE-SENTENCE "Enter the number of exact matches ")
    (WRITE-SENTENCE "(i.e. the correct color and column).")
    (LOOP
      (SETQ BLACKS (READ-BYTE))
      ((EQ BLACKS 27)
	(CLEAR-SCREEN)
	(RETURN) )
      (DECQ BLACKS 48)
      ((<= 0 BLACKS 4))
      (WRITE-BYTE 7) )
    (CLEAR-SCREEN)
    (META-OUTPUT-WINDOW)
    (SET-CURSOR MOVE-ROW (+ MOVE-COL 31))
    (PRIN1 BLACKS)
    ((EQ BLACKS 4)
      (META-PROMPT-WINDOW)
      (CLEAR-SCREEN)
      (CENTER "Hurray, I solved it!") )
    (META-PROMPT-WINDOW)
    (CLEAR-SCREEN)
    (WRITE-SENTENCE "Enter the number of correct colors in the wrong column.")
    (LOOP
      (SETQ WHITES (READ-BYTE))
      ((EQ WHITES 27)
	(CLEAR-SCREEN)
	(RETURN) )
      (DECQ WHITES 48)
      ((<= 0 WHITES (- 4 BLACKS)))
      (WRITE-BYTE 7) )
    (CLEAR-SCREEN)
    (META-OUTPUT-WINDOW)
    (SET-CURSOR MOVE-ROW (+ MOVE-COL 34))
    (PRIN1 WHITES)
    (SETQ GRAPH (MKGRAPH MOVE BLACKS WHITES MOVE NIL GRAPH *KEYLIST*))
    (INCQ GUESS-CTR)
    (TERPRI 2)
    (SETQ MOVE-ROW (ROW))
    (SETQ ERROR NIL
	  KEYLST *KEYLIST*
	  MOVE (MKMOVE GRAPH (POP KEYLST)))
    ((EVAL ERROR)
      (META-PROMPT-WINDOW)
      (CLEAR-SCREEN)
      (CENTER "One of your clues was incorrect.") ) ) )

(DEFUN FIRST-MOVE (KEY)
  (LIST (CAR KEY) (CADDR KEY) (CAR KEY) (CADDR KEY)) )

(DEFUN NUGRAPH (MOVE)
  ((NULL MOVE) T)
  (NUROW (NUGRAPH (CDR MOVE)) (CAR *KEYLIST*)) )

(DEFUN NUROW (GRAPH KEY)
  ((NULL KEY) NIL)
  (CONS GRAPH (NUROW GRAPH (CDR KEY))) )

(DEFUN MKMOVE (GRAPH KEY)
  (LOOP
    ((NULL GRAPH)
      (SETQ ERROR T) NIL)
    ((CAR GRAPH)
      ((ATOM (CAR GRAPH))
	(LIST (CAR KEY)) )
      (CONS (CAR KEY) (MKMOVE (CAR GRAPH) (POP KEYLST))) )
    (POP GRAPH)
    (POP KEY) ) )

(DEFUN MKGRAPH (MOVE BLACKS WHITES FREE UNUSED GRAPH KEYLST)
  ((NULL MOVE)
    ((ZEROP BLACKS)
      (EQ WHITES (INCOMMON FREE UNUSED)) ) )
  (MKNODE GRAPH (CAR KEYLST)) )

(DEFUN MKNODE (GRAPH KEY)
  ((NULL KEY) NIL)
  ((NULL (CAR GRAPH))
    (CONSNIL (MKNODE (CDR GRAPH) (CDR KEY))) )
  ((EQ (CAR MOVE) (CAR KEY))
    ((PLUSP BLACKS)
      (CONSNULL (MKGRAPH (CDR MOVE) (SUB1 BLACKS) WHITES
	(REMBER1 (CAR KEY) FREE) UNUSED (CAR GRAPH) (CDR KEYLST))
	  (MKNODE (CDR GRAPH) (CDR KEY))) )
    (CONSNIL (MKNODE (CDR GRAPH) (CDR KEY))) )
  (CONSNULL (MKGRAPH (CDR MOVE) BLACKS WHITES FREE
    (CONS (CAR KEY) UNUSED) (CAR GRAPH) (CDR KEYLST))
      (MKNODE (CDR GRAPH) (CDR KEY))) )

(DEFUN CONSNULL (X Y)
  ((NULL X)
    ((NULL Y) NIL)
    (CONS NIL Y) )
  (CONS X Y) )

(DEFUN CONSNIL (X)
  ((NULL X) NIL)
  (CONS NIL X) )

(DEFUN INCOMMON (LST1 LST2
    TOT )
  (SETQ TOT 0)
  (LOOP
    ((OR (NULL LST1) (NULL LST2)) TOT)
    ( ((MEMBER (CAR LST1) LST2)
	(SETQ LST2 (REMBER1 (CAR LST1) LST2))
	(INCQ TOT) ) )
    (POP LST1) ) )

(DEFUN PLAY-CODE-BREAKER (
     BYTE CODE GUESS CLUES GUESS-CTR COLOR MOVE-ROW MOVE-COL)
  (SETQ *KEYLIST* (MAPCAR 'PERMUTE-CODE *KEYLIST*)
	*SEED* (ADD1 (MOD (TIME) 100))
	CODE (MAPCAR '(LAMBDA (KEY) (NTH (RANDOM-NUMBER 4) KEY)) *KEYLIST*))
  (META-PROMPT-WINDOW)
  (CLEAR-SCREEN)
  (CENTER "Blue  Green	Pink  Red  White  Yellow")
  (TERPRI)
  (CENTER "Guess the color of this column.")
  (META-OUTPUT-WINDOW)
  (CLEAR-SCREEN)
  (CENTER "The Metamind Code Breaking Game")
  (TERPRI 2)
  (WRITE-SENTENCE "After you guess four colors, I will display the number ")
  (WRITE-SENTENCE "of correct colors in the correct column (i.e. the exact ")
  (WRITE-SENTENCE "matches) and the number ")
  (WRITE-SENTENCE "of correct colors that were in the wrong column.")
  (TERPRI 2)
  (SETQ MOVE-ROW (ROW)
	MOVE-COL (MAX 0 (TRUNCATE (- (CADDDR *META-WINDOW*) 35) 2))
	GUESS-CTR 1)
  (CLEAR-INPUT)
  (META-OUTPUT-WINDOW)
  (LOOP
    (SET-CURSOR MOVE-ROW MOVE-COL)
    (WRITE-STRING "Move: ")
    (PRIN1 GUESS-CTR)
    (SETQ GUESS)
    (LOOP
      ((= (LENGTH GUESS) (LENGTH CODE)))
      (SET-CURSOR MOVE-ROW (+ MOVE-COL 10 (* 5 (LENGTH GUESS))))
      (WRITE-STRING "???")
      (SET-CURSOR MOVE-ROW (+ MOVE-COL 10 (* 5 (LENGTH GUESS))))
      (SETQ BYTE (READ-BYTE))
      ((EQ BYTE 27)
	(META-PROMPT-WINDOW)
	(CLEAR-SCREEN)
	(RETURN) )
      (SETQ COLOR (POSITION (CHAR-UPCASE (ASCII BYTE)) '(B G P R W Y)))
      ( ((NOT COLOR)
	  (CLEAR-INPUT)
	  (WRITE-BYTE 7) )
	(PUSH (NTH COLOR '(BLU GRN PNK RED WHI YEL)) GUESS)
	(WRITE-STRING (CAR GUESS)) ) )
    (SETQ CLUES (CODE-CLUES CODE (NREVERSE GUESS) 0))
    (SET-CURSOR MOVE-ROW (+ MOVE-COL 31))
    (PRIN1 (CAR CLUES))
    (SET-CURSOR MOVE-ROW (+ MOVE-COL 34))
    (PRIN1 (CADR CLUES))
    ((EQ (CAR CLUES) 4)
      (META-PROMPT-WINDOW)
      (CLEAR-SCREEN)
      (CENTER "Congratulations, you solved it!") )
    (SET-CURSOR MOVE-ROW 0)
    (TERPRI 2)
    (SETQ MOVE-ROW (ROW))
    (INCQ GUESS-CTR) ) )

(DEFUN CODE-CLUES (CODE1 MOVE1 BLACKS CODE2 MOVE2)
  ((NULL CODE1)
    (LIST BLACKS (SAME-TYPE CODE2 MOVE2 0)) )
  ((EQ (CAR CODE1) (CAR MOVE1))
    (CODE-CLUES (CDR CODE1) (CDR MOVE1) (ADD1 BLACKS) CODE2 MOVE2) )
  (CODE-CLUES (CDR CODE1) (CDR MOVE1) BLACKS
	      (CONS (CAR CODE1) CODE2)
	      (CONS (CAR MOVE1) MOVE2)) )

(DEFUN SAME-TYPE (CODE MOVE WHITES)
  ((NULL CODE) WHITES)
  ((MEMBER (CAR CODE) MOVE)
    (SAME-TYPE (CDR CODE) (REMBER1 (CAR CODE) MOVE) (ADD1 WHITES)) )
  (SAME-TYPE (CDR CODE) MOVE WHITES) )


(DEFUN PERMUTE-CODE (LST1 LST2 LST3)
  ((NULL LST1)
    (NCONC LST2 LST3) )
  ((NULL (CDR LST1))
    (NCONC (CONS (CAR LST1) LST3) LST2) )
  ((NULL (CDDR LST1))
    (NCONC (PERMUTE-CODE (CONS (CAR LST1) LST2))
	   (PERMUTE-CODE (CONS (CADR LST1) LST3))) )
  (PERMUTE-CODE (CDDDR LST1)
		(CONS (CADR LST1) LST3)
		(LIST* (CADDR LST1) (CAR LST1) LST2)) )

(SETQ *KEYLIST* '((BLU GRN WHI YEL RED PNK)
		  (RED YEL GRN PNK BLU WHI)
		  (PNK BLU YEL GRN WHI RED)
		  (YEL WHI RED PNK BLU GRN)))


(DEFUN REMBER1 (X L)
  ((NULL L) NIL)
  ((EQ X (CAR L)) (CDR L))
  (CONS (CAR L) (REMBER1 X (CDR L))) )

(DEFUN RANDOM-NUMBER (NUM)
  (SETQ *SEED* (REM (+ 2113233 (* *SEED* 271821)) 9999991))
  (REM *SEED* NUM) )

(DEFUN META-OUTPUT-WINDOW ()
  (MAKE-WINDOW (CAR *META-WINDOW*)
	       (CADR *META-WINDOW*)
	       (- (CADDR *META-WINDOW*) 2)
	       (CADDDR *META-WINDOW*)) )

(DEFUN META-PROMPT-WINDOW ()
  (MAKE-WINDOW (- (+ (CAR *META-WINDOW*) (CADDR *META-WINDOW*)) 2)
	       (CADR *META-WINDOW*)
	       2
	       (CADDDR *META-WINDOW*)) )

(DEFUN CENTER (MSG)
  (SET-CURSOR (ROW) (TRUNCATE (- (CADDDR (MAKE-WINDOW)) (LENGTH MSG)) 2))
  (WRITE-SENTENCE MSG) )

(DEFUN WRITE-SENTENCE (SENTENCE
    INDEX COLS *AUTO-NEWLINE*)
  (SETQ COLS (CADDDR (MAKE-WINDOW)))
  (LOOP
    ((EQ SENTENCE ""))
    (SETQ INDEX (- COLS (COLUMN)))
    ((NULL (CHAR SENTENCE INDEX))
      (WRITE-STRING SENTENCE) )
    (LOOP
      ((EQ (CHAR SENTENCE INDEX) " ")
	(WRITE-LINE (SUBSTRING SENTENCE 0 (SUB1 INDEX)))
	(SETQ SENTENCE (STRING-LEFT-TRIM " " (SUBSTRING SENTENCE INDEX))) )
      ((ZEROP INDEX)
	((ZEROP (COLUMN))
	  (WRITE-LINE (SUBSTRING SENTENCE 0 (SUB1 COLS)))
	  (SETQ SENTENCE (STRING-LEFT-TRIM " " (SUBSTRING SENTENCE COLS))) )
	(TERPRI) )
      (DECQ INDEX) ) ) )

(PROGN ((GETD 'WINDOWS T))
       (CLOSE-INPUT-FILE (FIND "METAMIND.LSP" (INPUT-FILES) 'FINDSTRING))
       (METAMIND) )

(SETQ *INIT-WINDOW* "Metamind")
(SETQ *WINDOW-TYPES* (SORT (ADJOIN "Metamind" *WINDOW-TYPES*) 'STRING<))
(SETQ DRIVER 'WINDOWS)

(DEFUN "Metamind" (COMMAND)
  ((EQ COMMAND 'CREATE-WINDOW)
    (LIST "Metamind") )
  ((EQ COMMAND 'CLOSE-WINDOW))
  ((EQ COMMAND 'UPDATE-WINDOW)
    (CURRENT-WINDOW)
    (METAMIND-DISPLAY) )
  (METAMIND-STATUS)
  (LOOP
    (EXECUTE-OPTION 'COMMAND *METAMIND-OPTIONS*) ) )

(SETQ *METAMIND-OPTIONS* '(
	("Breaker" . RUN-CODE-BREAKER)
	("Maker" . RUN-CODE-MAKER)
	("Options" . (
		("Color" . (
			("Menu" . SET-MENU-COLOR)
			("Work" . SET-WORK-COLOR) ))
		("Display" . SET-DISPLAY)
		("Execute" . GO-DOS) ))
	("Quit" . QUIT-PROGRAM)
	("Window" . CHANGE-WINDOW) ))

(DEFUN RUN-CODE-BREAKER (
    *META-WINDOW* )
  (SHOW-PROMPT "Press ESC for options")
  (CURRENT-WINDOW)
  (CURSOR-OFF)
  (SETQ *META-WINDOW* (MAKE-WINDOW))
  (PLAY-CODE-BREAKER) )

(DEFUN RUN-CODE-MAKER (
    *META-WINDOW* )
  (SHOW-PROMPT "Press ESC for options")
  (CURRENT-WINDOW)
  (CURSOR-OFF)
  (SETQ *META-WINDOW* (MAKE-WINDOW))
  (PLAY-CODE-MAKER) )

(DEFUN METAMIND-STATUS ()
  (CLEAR-STATUS "Metamind")
  (WRITE-STRING "The Metamind Code Breaking Game") )

(PROGN
  (TERPRI)
  (WRITE-SENTENCE "Press the ESC key and open a \"Metamind\" window ")
  (WRITE-SENTENCE "to play this code breaking game.")
  (TERPRI) )
